home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / hdwr.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  9.6 KB  |  333 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         hdwr.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  A simple description of hardware objects using xlisp
  7. ;        Mix and match instances of the objects to create your
  8. ;        organization.
  9. ; Author:       Jwahar R. Bammi
  10. ; Created:      Sat Oct  5 20:52:14 1991
  11. ; Modified:     Sat Oct  5 20:53:14 1991 (Niels Mayer) mayer@hplnpm
  12. ; Language:     Lisp
  13. ; Package:      N/A
  14. ; Status:       X11r5 contrib tape release
  15. ;
  16. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  17. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  18. ;
  19. ; Permission to use, copy, modify, distribute, and sell this software and its
  20. ; documentation for any purpose is hereby granted without fee, provided that
  21. ; the above copyright notice appear in all copies and that both that
  22. ; copyright notice and this permission notice appear in supporting
  23. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  24. ; used in advertising or publicity pertaining to distribution of the software
  25. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  26. ; makes no representations about the suitability of this software for any
  27. ; purpose.  It is provided "as is" without express or implied warranty.
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. ; Needs:
  31. ; - busses and connection and the Design
  32. ;   Class that will have the connections as instance vars.
  33. ; - Print method for each object, that will display
  34. ;   the instance variables in an human readable form.
  35. ; Some day I will complete it.
  36. ;
  37. ;
  38. ;
  39. ; utility functions
  40.  
  41.  
  42. ; function to calculate 2^n
  43.  
  44. (defun pow2 (n)
  45.     (pow2x n 1))
  46.  
  47. (defun pow2x (n sum)
  48.        (cond((equal n 0) sum)
  49.         (t (pow2x (- n 1) (* sum 2)))))
  50.  
  51.  
  52. ; hardware objects
  53.  
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;The class areg
  56.  
  57. (setq areg (Class :new '(value nbits max_val min_val)))
  58.  
  59. ; methods
  60.  
  61. ; initialization method
  62. ; when a new instance is called for the user supplies
  63. ; the parameter nbits, from which the max_val & min_val are derived
  64.  
  65. (areg :answer :isnew '(n)
  66.       '((self :init n)
  67.             self))
  68.  
  69. (areg :answer :init '(n)
  70.       '((setq value ())
  71.         (setq nbits n)
  72.         (setq max_val (- (pow2 (- n 1)) 1))
  73.         (setq min_val (- (- 0 max_val) 1))))
  74.  
  75. ; load areg
  76.  
  77. (areg :answer :load '(val)
  78.       '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
  79.           ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
  80.           (t (setq value val)))))
  81.  
  82. ; see areg
  83.  
  84. (areg :answer :see '()
  85.       '((cond ((null value) (princ "Register does not contain a value\n"))
  86.           (t value))))
  87. ;
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89.  
  90. ; The class creg ( a register that can be cleared and incremented)
  91. ; subclass of a reg
  92.  
  93. (setq creg (Class :new '() '() areg))
  94.  
  95. ; it inherites all the instance vars & methods of a reg
  96. ; in addition to them it has the following methods
  97.  
  98. (creg :answer :isnew '(n)
  99.       '((self :init n)
  100.     self))
  101.  
  102. (creg :answer :init '(n)
  103.       '((setq value ())
  104.     (setq nbits n)
  105.     (setq max_val (- (pow2 n) 1))
  106.     (setq min_val 0)))
  107.  
  108. (creg :answer :clr '()
  109.       '((setq value 0)))
  110.  
  111. (creg :answer :inc '()
  112.       '((cond ((null value) (princ "Register does not contain a value\n"))
  113.           (t (setq value (rem (+ value 1) (+ max_val 1)))))))
  114.  
  115. ;
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117. ;
  118. ; Register bank
  119. ; contains n areg's n_bits each
  120.  
  121. (setq reg_bank (Class :new '(regs n_regs curr_reg)))
  122.  
  123. ;methods
  124.  
  125. (reg_bank :answer :isnew '(n n_bits)
  126.       '((self :init n n_bits)
  127.         self))
  128.  
  129. (reg_bank :answer :init '(n n_bits)
  130.       '((setq regs ())
  131.         (setq n_regs (- n 1))
  132.         (self :initx n n_bits)))
  133.  
  134. (reg_bank :answer :initx '(n n_bits)
  135.       '((cond ((equal n 0) t)
  136.               (t (list (setq regs (cons (areg :new n_bits) regs))
  137.           (self :initx (setq n (- n 1)) n_bits))))))
  138.  
  139. (reg_bank :answer :load '(reg val)
  140.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  141.          (t (setq curr_reg (nth (+ reg 1) regs))
  142.             (curr_reg :load val)))))
  143.  
  144. (reg_bank :answer :see '(reg)
  145.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  146.          (t (setq curr_reg (nth (+ reg 1) regs))
  147.             (curr_reg :see)))))
  148. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  149. ; The Class alu
  150.  
  151. ;alu - an n bit alu
  152.  
  153. (setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
  154.  
  155. ; methods
  156.  
  157. (alu :answer :isnew '(n)
  158.      '((self :init n)
  159.        self))
  160.  
  161. (alu :answer :init '(n)
  162.      '((setq n_bits n)
  163.        (setq maxu_val (- (pow2 n) 1))
  164.        (setq maxs_val (- (pow2 (- n 1)) 1))
  165.        (setq mins_val (- (- 0 maxs_val) 1))
  166.        (setq minu_val 0)
  167.        (setq nf 0)
  168.        (setq zf 0)
  169.        (setq vf 0)
  170.        (setq cf 0)))
  171.  
  172. (alu :answer :check_arith '(a b)
  173.      '((cond ((and (self :arith_range a) (self :arith_range b)) t)
  174.          (t ()))))
  175.  
  176. (alu :answer :check_logic '(a b)
  177.      '((cond ((and (self :logic_range a) (self :logic_range b)) t)
  178.          (t ()))))
  179.  
  180. (alu :answer :arith_range '(a)
  181.      '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
  182.          ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
  183.              (t t))))
  184.  
  185. (alu :answer :logic_range '(a)
  186.      '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
  187.              (t t))))
  188.  
  189. (alu :answer :set_flags '(a b r)
  190.      '((if (equal 0 r) ((setq zf 1)))
  191.        (if (< r 0) ((setq nf 1)))
  192.        (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
  193.           (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
  194.        (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
  195.           (and (>= r 0) (< b 0))) ((setq cf 1)))))
  196.        
  197. (alu :answer :+ '(a b &aux result)
  198.      '((cond ((null (self :check_arith a b)) ())
  199.         (t (self :clear_flags)
  200.            (setq result (+ a b))
  201.            (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
  202.            (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
  203.            (self :set_flags a b result)
  204.            result))))
  205.  
  206. (alu :answer :& '(a b &aux result)
  207.      '((cond ((null (self :check_logic a b)) ())
  208.         (t (self :clear_flags)
  209.            (setq result (bit-and a b))
  210.            (self :set_flags a b result)
  211.            result))))
  212.  
  213. (alu :answer :| '(a b &aux result)
  214.      '((cond ((null (self :check_logic a b)) ())
  215.         (t (self :clear_flags)
  216.            (setq result (bit-ior a b))
  217.            (self :set_flags a b result)
  218.            result))))
  219.  
  220. (alu :answer :~ '(a  &aux result)
  221.      '((cond ((null (self :check_logic a 0)) ())
  222.         (t (self :clear_flags)
  223.            (setq result (bit-not a))
  224.            (self :set_flags a 0 result)
  225.            result))))           
  226.  
  227. (alu :answer :- '(a b)
  228.      '((self '+ a (- 0 b))))
  229.  
  230. (alu :answer :passa '(a)
  231.      '(a))
  232.  
  233. (alu :answer :zero '()
  234.      '(0))
  235.  
  236. (alu :answer :com '(a)
  237.      '((self :- 0 a)))
  238.  
  239. (alu :answer :status '()
  240.      '((princ (list "NF "nf"\n"))
  241.        (princ (list "ZF "zf"\n"))
  242.        (princ (list "CF "cf"\n"))
  243.        (princ (list "VF "vf"\n"))))
  244.  
  245. (alu :answer :clear_flags '()
  246.      '((setq nf 0)
  247.        (setq zf 0)
  248.        (setq cf 0)
  249.        (setq vf 0)))
  250.  
  251. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  252. ;
  253. ; The class Memory
  254. ;
  255.  
  256. (setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
  257.  
  258. ; methods
  259.  
  260. (memory :answer :isnew '(addr_bits data_bits)
  261.      '((self :init addr_bits data_bits)
  262.        self))
  263.  
  264. (memory :answer :init '(addr_bits data_bits)
  265.      '((setq nabits addr_bits)
  266.        (setq ndbits data_bits)
  267.        (setq maxu_val (- (pow2 data_bits) 1))
  268.        (setq max_addr (- (pow2 addr_bits) 1))
  269.        (setq maxs_val (- (pow2 (- data_bits 1)) 1))
  270.        (setq mins_val (- 0 (pow2 (- data_bits 1))))
  271.        (setq undef (+ maxu_val 1))
  272.        (setq memry (array :new max_addr undef))))
  273.  
  274.  
  275. (memory :answer :load '(loc val)
  276.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  277.          ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
  278.          ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  279.          (t (memry :load loc val)))))
  280.  
  281. (memory :answer :write '(loc val)
  282.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  283.          ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  284.          ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  285.          (t (memry :load loc val)))))
  286.  
  287.  
  288. (memory :answer :read '(loc &aux val)
  289.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  290.          (t (setq val (memry :see loc))
  291.         (cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
  292.               (t val))))))
  293.  
  294.  
  295. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  296. ;
  297. ; The class array
  298.  
  299. (setq array (Class :new '(arry)))
  300.  
  301. ; methods
  302.  
  303. (array :answer :isnew '(n val)
  304.        '((self :init n val)
  305.      self))
  306.  
  307. (array :answer :init '(n val)
  308.     '((cond ((< n 0) t)
  309.           (t (setq arry (cons val arry))
  310.          (self :init (- n 1) val)))))
  311.  
  312. (array :answer :see '(n)
  313.            '((nth (+ n 1) arry)))
  314.  
  315.  
  316. (array :answer :load '(n val &aux left right temp)
  317.        '((setq left (self :left_part n arry temp))
  318.      (setq right (self :right_part n arry))
  319.      (setq arry (append left (list val)))
  320.      (setq arry (append arry right))
  321.      val))
  322.  
  323. (array :answer :left_part '(n ary left)
  324.        '((cond ((equal n 0) (reverse left))
  325.            (t (setq left (cons (car ary) left))
  326.           (self :left_part (- n 1) (cdr ary) left)))))
  327.  
  328. (array :answer :right_part '(n ary &aux right)
  329.        '((cond ((equal n 0) (cdr ary))
  330.            (t (self :right_part (- n 1) (cdr ary))))))
  331.  
  332. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  333.